home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d10
/
ps1410.arc
/
CAL3.BAS
< prev
next >
Wrap
BASIC Source File
|
1990-10-31
|
77KB
|
2,070 lines
'=========================================================================
' Personal Calendar (PC) Program
' Copyright (c) 1985-1990, Paul Munoz-Colman. All Rights Reserved.
' Version 14.10
' 31 Oct 1990
' Shareware $25
'=========================================================================
' DOS File CAL3.BAS
' Independently Compiled Subprograms Which Are Linked With CAL1.BAS
'=========================================================================
' Written For IBM PCs & Compatibles Under MS DOS 3.30 on a Northgate 486
' Compiled By Microsoft Professional BASIC 7.10, Linker Version 5.10
'=========================================================================
' Note -- Tabs in the source file are in positions 6,11,16,21,26,...
'=========================================================================
' $INCLUDE: 'cal1.bi'
'=========================================================================
' Subprogram List in the Order of Appearance in this File
' (compiled WITHOUT error handling--no /E or /X)
'-------------------------------------------------------------------------
' Name Purpose
' --------------------------- ---------------------------------------
' ApptToMenu (EntryPoint) Raw Appt Rec to Menu and Vice Versa
' Fn ASCIIN$ (ASCIIZString$) Strip Chr$(0) From ASCIIZ String
' Fn ASCIIZ$ (ASCIIString$) Add Chr$(0) to ASCII String
' AutoStart Automatic Startup Setting Menu
' BigChars (CharsLin%, CharsColumn%, ChLin$) Interface with MhChars
' BlankError Clear Error Message
' BlankFatal Clear Fatal Error (2 lines)
' Fn BlankFill$ (ToBlankFill$) Leading Zeroes to Blanks in String
' BoxDraw (Type, Top, Bottom, Left, Right) Draw Box with MhBox
' BuildMenuLine Construct Menu Event Line
' CheckDate (DatetoValidate$) See If Date Is Really a Date
' ClearLast3 Blank Last 3 Screen Lines
' ClearLast4 Blank Last 4 "
' ClearOverdueTable Clear Events Overdue Listing
' ClearScreenNormal (TimerDesired)
' Clear Screen with Cl1f,Cl1b colors
' CloseFiles Close All Data Files
' ColorDecode (ColorAttribute) Get Colors from Attribute
' CombineDateTime Merge Date/Time Fields
' CompressApptFile (ShrinkNumber)
' Compress Appt File ShrinkNumber Recs
' ComputePendingValue (AlarmValue#,PendingValue#)
' Calculate Warning Date/Time
' ControlledInput (BoxRow,BoxColumn,MessageRow,MessageColumn,Length,_
' MessageText$,InputResponse$,NumlockRequest,FilenameShow,_
' ScreenBottomsShow,HoldAtEnd) General Input Routine
' Credits (WhichLine) Address, phone number, regi info
' DayDate (DatetoIndex$) Get Day of Week and count for a Date
' Fn DirectoryExist(DirectoryName$) Interface with MhDirExist
' DirectReturnCheck Whether Returning To Clock Screen
' DisplayApptFilename Show Appointment File Name on Menus
' DOSBIOSServices Interface to MhDOS2
' DoShell (ShellCommand$) Run a Shell Command
' DOSShell Run DOS Session and Return
' EndItAll Return to DOS
' ErrorHandler Error Condition Message Generator
' EscapeLine Esc to Return Instruction
' EscapeLineDelete Esc to Return Instruction Blankout
' EventErrorMessage Display Error On Editing Instructions
' Fn FileExist(ExistFilename$) Interface with MhFileExist
' FileFormat Change Number of Notes/Events in File
' FileList Display List of Appointment Files
' GenerateGreeting Display Main Menu Greeting
' GenGreetingScreen1 Startup Screen
' GetFilenameLength Get Length of Appointment File Name
' GetOptions Read Options from Appointment File
' Help Help Function
' IncrementDate (DatetoIncrement$)
' Change a Date to the Next Date
' InitPrinter Initialize Printer w/Control Codes
'=========================================================================
SUB ApptToMenu (EntryPoint) STATIC
'=========================================================================
' Convert Raw Appt Record to Menu Item (Entry Point 1)
' Convert Menu Item to Raw Appt Recrd (Entry Point 2) -- future use
DEFINT A-Z
SubnumSave = Subnum
Subnum = 133
CALL GetApptRecord(N1+WhichEvent) 'Fills CurrentEventRecord$
CALL UnpackApptRecord 'Gets Individual Event Elements
CALL CombineDateTime 'Gets Day of Week
CALL BuildMenuLine 'Fills CurrentEventLine$
Subnum = SubnumSave
END SUB
'=========================================================================
FUNCTION ASCIIN$ (ASCIIZString$) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 2
' Take the Chr$(0) off an ASCIIZ String for Mh Routines
ZeroPosition = InString(ASCIIZString$, CHR$(N0))
IF ZeroPosition THEN
ASCIIN$ = LEFT$(ASCIIZString$, ZeroPosition - N1)
ELSE
ASCIIN$ = ASCIIZString$
END IF
Subnum = SubnumSave
END FUNCTION
'=========================================================================
FUNCTION ASCIIZ$ (ASCIIString$) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 3
' Add the Chr$(0) to an ASCII String for Mh Mach2 Routines
IF RIGHT$(ASCIIString$, N1) <> CHR$(N0) THEN
ASCIIZ$ = ASCIIString$ + CHR$(N0)
ELSE
ASCIIZ$ = ASCIIString$
END IF
Subnum = SubnumSave
END FUNCTION
'=========================================================================
SUB AutoStart STATIC
'=========================================================================
' Automatic Startup and TSR Mode (if DOS 3 or later) options
DEFINT A-Z
SubnumSave = Subnum
Subnum = 4
BeginAuto:
CALL ClearScreenNormal(N1)
'------------------------------------------------------------------------
IF NOT DOS2x THEN
ScreenTitles$(N1) = "Memory-Resident Options and Automatic Startup"
CALL Titles(Nm1)
MenuSize = N2
MenuLines(N1) = "Memory-Resident (TSR Mode) Options"
MenuLines(N2) = "Automatic Startup Options"
CALL MenuDriver(MenuSize, MenuAutoTSR, N7, Nm1, _
No, N0, N1, N1)
IF MenuExit = MenuCancelled THEN
CALL DirectReturnCheck
CALL ClearScreenNormal(N1)
GOTO ExitPoint
END IF
SELECT CASE MenuAutoTSR
CASE 1 ' TSR Options Menu
CALL StayResOptions(No)
CASE 2 ' Autostart Options Menu
ActionNote = N0
GOTO BuildAutoMenu
END SELECT
GOTO BeginAuto
END IF
'------------------------------------------------------------------------
BuildAutoMenu:
CALL ClearScreenNormal(N1)
ScreenTitles$(N1) = "Automatic Startup"
CALL Titles(Nm1)
SELECT CASE ActionNote
CASE 0 ' No Message
CASE 1 ' Auto/Appointment
ActionMessage$ = "Automatic Startup Set With Appointment File"
CASE 2 ' Auto/No Appointment
ActionMessage$ = "Automatic Startup Set Without Appointment File"
CASE 3 ' Manual
ActionMessage$ = "Manual Startup Set"
CASE 4
IF ForceDate THEN
ActionMessage$ = "Set to Ask For Input of Date/Time"
ELSE
ActionMessage$ = "Will Not Ask For Input of Date/Time"
END IF
END SELECT
IF ActionNote THEN
CALL PrepareforMessage
CALL ShowIt(N0,N0,N0,ActionMessage$)
ActionNote = N0
END IF
MenuSize = 4
MenuRow = N7
MenuLines(N1) = "Automatic Startup With Appointment File"
MenuLines(N2) = "Automatic Startup With Clock and Calendar Only"
MenuLines(N3) = "Manual Startup"
MenuLines(4) = _
"Ask For Date and Time When Program Starts, Currently "
CALL MhNotBackwardInstr(Pointer%, N1%, (MenuLines(N4)), N32%)
IF ForceDate THEN
ScreenTag$ = Yess$
ELSE
ScreenTag$ = "No "
END IF
CALL Myd2(MenuLines(N4), Pointer + N2, N3, ScreenTag$)
CALL MenuDriver(MenuSize, MenuAuto, MenuRow, Nm1, No, N0, N1, N1)
CALL BlankError
IF MenuExit = MenuCancelled THEN
CALL DirectReturnCheck
CALL ClearScreenNormal(N1)
IF NOT DOS2x THEN GOTO BeginAuto ELSE GOTO ExitPoint
END IF
ActionNote = MenuAuto
'------------------------------------------------------------------------
SELECT CASE MenuAuto
CASE 1 ' Autostart with Appt File
AutostartMode = Yes
BoxRow = MenuRow + MenuSize + 4
MessageRow = BoxRow
InputResponse$ = ApptFilename$
CALL ControlledInput(BoxRow, N40, MessageRow, N1, N8, _
"Enter Appointment File Name", InputResponse$, _
N0, N1, N1, N1)
IF Keystroke$ = CHR$(Esc) THEN GOTO BuildAutoMenu
IF InputResponse$ <> ApptFilename$ THEN EventTableStable = No
ApptFilename$ = InputResponse$
' File Password
BoxRow = MenuRow + MenuSize + 5
MessageRow = BoxRow
PasswordCheck:
FOR I = N1 TO N2
IF I = N1 THEN
MessageText$ = "Enter Appointment File Password "
ELSE
MessageText$ = "Re-Enter Password To Confirm, Please"
END IF
InputResponse$ = SPACE$(8)
EchoSuppression = Yes
CALL ControlledInput(BoxRow, N40, MessageRow, N1, N8, _
MessageText$, InputResponse$, N0, N1, N1, N1)
EchoSuppression = No
IF Keystroke$ = CHR$(Esc) THEN GOTO BuildAutoMenu
CALL BlankFatal
IF I = N1 THEN PasswordHold$ = InputResponse$
NEXT
IF PasswordHold$ <> InputResponse$ THEN
CALL MajorBeeper
CALL Kolors(N14)
CALL BlankError
CALL ShowIt(N0, N0, N0, _
"Password Confirmation Doesn't Match -- Try Again")
GOTO PasswordCheck
END IF
ApptPassword$ = InputResponse$
EnteredPassword$ = InputResponse$
CASE 2 ' Autostart without Appt File
EventTableStable = No
ApptFilename$ = Blank8$
ApptPassword$ = Blank8$
AutostartMode = Yes
CASE 3 ' Manual start (later without appointment file)
AutostartMode = No
CASE 4
IF ForceDate THEN ' Force DOS Date/Time Set
ForceDate = No ' on Program Start
ELSE
ForceDate = Yes
END IF
END SELECT
CALL WriteCalauto ' Rewrite CALAUTO.DAT File
GOTO BuildAutoMenu
ExitPoint:
Subnum = SubnumSave
END SUB
'=========================================================================
SUB BigChars (CharRow%, CharColumn%, CharLin$) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 136
' Interface with MhChars
SPage% = ScreenPage% ' Error in MhChars changes the value
CAttribute% = ColorAttribute% ' of CColumn on return from the
CRow% = CharRow% ' routine
CColumn% = CharColumn%
CLin$ = CharLin$
CALL MhChars (SPage%, CRow%, CColumn%, CAttribute%, CLin$)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB BlankError STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 5
CALL ShowErase(N0, ErrMsgPlacement, N1, N80, Blank0$)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB BlankFatal STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 6
FOR I = N1 TO N2
CALL ShowErase(N0, (ErrMsgPlacement + I - N1), N1, N80, Blank0$)
NEXT
Subnum = SubnumSave
END SUB
'=========================================================================
FUNCTION BlankFill$ (ToBlankFill$) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 7
' Fill leading Zeroes with Blanks
BlankDummy$ = ToBlankFill$ ' Save String
IF LEN(BlankDummy$) THEN ' If non-null, find first non-zero
CALL MhNotInstr(FirstNonZero%, Start%, BlankDummy$, N48%)
IF FirstNonZero > N1 THEN 'if one in pos 2 or more => zeroes
ToFill = FirstNonZero - N1 ' Fill them all with blanks
CALL Myd2(BlankDummy$, N1, ToFill, Strng$(ToFill, N32))
END IF
END IF
BlankFill$ = BlankDummy$ ' and save the result
Subnum = SubnumSave
END FUNCTION
'=========================================================================
SUB BoxDraw (BoxType, BoxTop, BoxBottom, BoxLeft, BoxRight) STATIC
'=========================================================================
' Draw a Box with MhBox, Simplifying Calling Parameters
DEFINT A-Z
SubnumSave = Subnum
Subnum = 32
CALL MhBox(ColorAttribute%, BoxType%, ColorAttribute%, ScreenPage%, _
BoxTop%, BoxLeft%, BoxBottom%, BoxRight%)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB BuildMenuLine STATIC
'=========================================================================
' Construct Individual Event Menu Line--Compute Day Of Week
DEFINT A-Z
SubnumSave = Subnum
Subnum = 103
IF CurrentEventRecord$ = Blank80$ THEN
CALL MhLset(CurrentEventLine$, NullEvent$)
GOTO ExitPoint0
END IF
ScreenTag$ = Blank3$
IF EventDate$ <> Blank8$ THEN ' First Try To Get It From The
J = N0 ' Weekly or Monthly "N" Day Indicator Digit
ErrorSwitch = No
IF InString("BbWwNn123456789", MID$(EventRepeat$, N1, N1)) THEN
J = VAL(MID$(EventRepeat$, N2, N1))
END IF
IF J <= N0 OR J >= 8 THEN 'If Not There or No Good
' Compute It From The Date
CALL BuildMenuDate(EventDate$) ' does error handling
J = IndexedDay
END IF
IF NOT ErrorSwitch THEN
'-----------------------------------------------------
' Get The Alphabetic Day Of The Week For The Display
CALL Myd2(ScreenTag$, N1, N3, DayNames$(J))
END IF
ErrorSwitch = No
END IF
'-------------------------------------------------------------------------
' Place Each Data Field Where It Belongs In The Menu Line
IF EventLimRepeat$ = Blank2$ THEN
CALL Myd2(LimSep$, N1, N1, Blank1$)
ELSE
CALL Myd2(LimSep$, N1, N1, Hyphen$)
END IF
CALL Myd2(CurrentEventLine$, N1, N2, EventLimRepeat$)
CALL Myd2(CurrentEventLine$, N3, N1, LimSep$)
CALL Myd2(CurrentEventLine$, N4, N3, EventRepeat$)
CALL Myd2(CurrentEventLine$, N7, N1, Blank1$)
CALL Myd2(CurrentEventLine$, N8, N2, EventMonth$)
CALL Myd2(CurrentEventLine$, N10, N1, Hyphen$)
CALL Myd2(CurrentEventLine$, N11, N2, EventDay$)
CALL Myd2(CurrentEventLine$, N13, N1, Hyphen$)
CALL Myd2(CurrentEventLine$, N14, N2, EventYear$)
CALL Myd2(CurrentEventLine$, N16, N1, Blank1$)
CALL Myd2(CurrentEventLine$, N17, N3, ScreenTag$)
CALL Myd2(CurrentEventLine$, N20, N1, Blank1$)
CALL Myd2(CurrentEventLine$, N21, N2, EventHour$)
CALL Myd2(CurrentEventLine$, N23, N1, ":")
CALL Myd2(CurrentEventLine$, N24, N2, EventMinute$)
CALL Myd2(CurrentEventLine$, N26, N2, Blank2$)
CALL Myd2(CurrentEventLine$, N28, TextSize, EventText$)
ExitPoint0:
Subnum = SubnumSave
END SUB
'=========================================================================
SUB CheckDate (DateToValidate$) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 8
' Check Date For Validity
' Input DateToValidate$ (YYYYMMDDHHMM)
' Output DateValidation 0 or 1 (Error)
DateValidation = N0
ReturnMessage$ = Blank0$
' Check Date/Time
IF MID$(DateToValidate$, N1, 8) = Blank8$ THEN
CALL Myd2(DateToValidate$, N1, N8, TodaysDate$)
END IF
' Date
IF MID$(DateToValidate$, 9, 4) = SPACE$(4) THEN
CALL Myd2(DateToValidate$, N9, N4, CurrentTime$)
END IF
' Time
IF NumberError(DateToValidate$) = N1 THEN
ReturnMessage$ = "Non-Numeric Date"
GOTO DateBad
END IF
' Numerics
ValidateYear = VAL(MID$(DateToValidate$, N1, 4))
FOR I = N1 TO 4
' Y,M,D,H,M
DateEdit(I) = VAL(MID$(DateToValidate$, I * N2 + N3, N2))
' Numeric
IF I < N3 AND DateEdit(I) <= N0 THEN
ReturnMessage$ = "Non-Positive Date"
GOTO DateBad
END IF
IF I > N2 AND DateEdit(I) <= Nm1 THEN
ReturnMessage$ = "Negative Date"
GOTO DateBad
END IF
IF I <> N2 THEN
' Days In Month
IF DateEdit(I) > DateEditLimits(I) THEN
ReturnMessage$ = "Date Too Large"
GOTO DateBad
ELSE
GOTO NextDatePart
END IF
END IF
IF DateEdit(N1) <> N2 OR DateEdit(N2) <> 29 THEN
' February 29th
IF DateEdit(N2) > MonthLength(DateEdit(N1)) THEN
ReturnMessage$ = "Date Too Large"
GOTO DateBad
ELSE
GOTO NextDatePart
END IF
END IF
' Days In Month
IF NOT Leap(ValidateYear) THEN
ReturnMessage$ = "Not Leap Year"
GOTO DateBad
END IF
' Leap Year
NextDatePart:
NEXT
GOTO ExitPoint2
' Ok
DateBad:
DateValidation = N1
' Error
ExitPoint2:
Subnum = SubnumSave
END SUB
'=========================================================================
SUB ClearLast3 STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 9
CALL ShowMult(N0, N23, N1, N80, N3)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB ClearLast4 STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 10
CALL ShowMult(N0, N22, N1, N80, N4)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB ClearOverdueTable STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 11
' Clear Overdue Event Table
CLOSE FilenumOverdue
CALL KillAFile(ApptFilenameOverdue$)
OverdueCount = N0
RedisplayCalendars = Yes
Subnum = SubnumSave
END SUB
'=========================================================================
SUB ClearScreenNormal (ClearTimerDesired) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 12
CALL Kolors(N6)
CLS
TimerDesired = ClearTimerDesired
IF TimerDesired THEN
TimerDisplaySuppress = No
CALL KeyStuff(KeyTimerInit) ' Show Timer & State Flags
CALL DisplayApptFilename ' & appt file name if one
ELSE
TimerDisplaySuppress = Yes
END IF
Subnum = SubnumSave
END SUB
'=========================================================================
SUB CloseFiles STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 13
CLOSE
ApptFile = No
Subnum = SubnumSave
END SUB
'=========================================================================
SUB ColorDecode (CDColorAttribute) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 14
' Given a color attribute, find the foreground and background colors
ColorBackground = (CDColorAttribute - (CDColorAttribute AND 128)) \ 16
ColorForeground = (CDColorAttribute - _
(CDColorAttribute AND 128)) MOD 16 + _
(CDColorAttribute AND 128) \ 8
Subnum = SubnumSave
END SUB
'=========================================================================
SUB CombineDateTime STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 15
CALL Myd2(EventDate$, N1, N2, EventYear1st2$)
CALL Myd2(EventDate$, N3, N2, EventYear$)
CALL Myd2(EventDate$, N5, N2, EventMonth$)
CALL Myd2(EventDate$, N7, N2, EventDay$)
CALL Myd2(EventTime$, N1, N2, EventHour$)
CALL Myd2(EventTime$, N3, N2, EventMinute$)
CALL Myd2(EventDateTime$, N1, N8, EventDate$)
CALL Myd2(EventDateTime$, N9, N4, EventTime$)
CombinedDateTime# = VAL(EventDateTime$)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB CompressApptFile (ShrinkNumber) STATIC
'=========================================================================
' Compress Appointment File By ShrinkNumber Records From the End
' Delete Blank or Duplicate History Records in the Process
DEFINT A-Z
SubnumSave = Subnum
Subnum = 104
CALL ShowErase(N14, N25, N1, N80, _
" Please Wait--Compressing Appointment File")
InputEOF = LOF(FilenumAppt) \ N80
' By Opening A New Appointment File ApptFilename$.cln
' And Copying The Old File To The New One
CALL KillAFile(ApptFilename$ + ".cln")
OutputIndex = N1
CLOSE FilenumNewAppt
OPEN "R", FilenumNewAppt, ApptFilename$ + ".cln", N80
FIELD FilenumNewAppt, N80 AS NewApptBuffer$
' Loop through File to Move Records
FOR InputIndex = N1 TO InputEOF - ShrinkNumber
CALL KeyStuff(KeyStatus)
CALL ShowIt(N14, N25, N49, (STR$(InputEOF - ShrinkNumber - _
InputIndex + N1) + SPACE$(N4))) ' Count
CALL GetApptRecord(InputIndex) ' Next Record
IF (InputIndex < StartingHistory) OR (ApptBuffer$ <> Blank80$ AND _
ApptBufferHold$ <> ApptBuffer$ AND _
ApptBuffer$ <> NullEvent$ AND _
ApptBuffer$ <> NullEventOld$) THEN
' Move Record To Output
CALL MhLset(NewApptBuffer$, ApptBuffer$)
PUT FilenumNewAppt, OutputIndex ' Write to New File
' Save for Next Comparison
ApptBufferHold$ = ApptBuffer$
OutputIndex = OutputIndex + N1 ' Bump Record Counter
END IF
IF (InputIndex - StartingHistory + N1) = (CurrentNoteHist) THEN
' Set New History Pointer
CurrentNoteHist = OutputIndex - StartingHistory + N1
END IF
NEXT
' Then Deleting The Old One,
' Renaming The New One ApptFilename$.cld
' And Reopening It As The Appointment File--Magic!
CALL CloseFiles
CALL KillAFile(ApptFilename$ + ".cld")
CALL MhRename ((ASCIIZ$(ApptFilename$ + ".cln")), _
(ASCIIZ$(ApptFilename$ + ".cld")), Ecode%)
IF Ecode THEN ERROR 255
CALL OpenAppts
Subnum = SubnumSave
END SUB
'=========================================================================
SUB ComputePendingValue (AlarmValue#, PendingValue#) STATIC
'=========================================================================
' Get Date/Time Subtracting Minutes Value (For Pending Function)
' Input is AlarmValue# (YYYYMMDDTTTT), Return is PendingValue# (Same)
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 16
' Break Down AlarmValue Into Parts
PendingString$ = RIGHT$(STR$(AlarmValue#), 12)
PendingYear = VAL(MID$(PendingString$, N1, 4))
PendingMonth = VAL(MID$(PendingString$, 5, N2))
PendingDay = VAL(MID$(PendingString$, N7, N2))
PendingHours = VAL(MID$(PendingString$, 9, N2))
PendingMinutes = VAL(MID$(PendingString$, 11, N2))
' Test if enough minutes left to subtract Pending
TestMinutes:
IF PendingMinutes >= Pending THEN
PendingMinutes = PendingMinutes - Pending
GOTO RebuildDate
END IF
' Not enough minutes, try hours
TestHours:
IF PendingHours > N0 THEN
PendingHours = PendingHours - N1
PendingMinutes = PendingMinutes + 60
GOTO TestMinutes
END IF
' Not enough hours, try days
TestDays:
IF PendingDay > N1 THEN
PendingDay = PendingDay - N1
PendingHours = PendingHours + 24
GOTO TestHours
END IF
' Not enough days, try months, (check for leap year if feb)
TestMonths:
IF PendingMonth > N1 THEN
PendingMonth = PendingMonth - N1
PendingDay = PendingDay + MonthLength(PendingMonth)
IF PendingMonth <> N2 THEN GOTO TestDays
PendingDay = PendingDay + Leap(PendingYear)
GOTO TestDays
END IF
' Not enough years, subtract one
PendingYear = PendingYear - N1
PendingMonth = PendingMonth + 12
GOTO TestMonths
' Put the value back together - no blanks
RebuildDate:
CALL YearAdjust(PendingYear, AdjustedYear$)
PendingString$ = ZeroFill$(AdjustedYear$ + RIGHT$(STR$(PendingMonth), _
N2) + RIGHT$(STR$(PendingDay), N2) + RIGHT$(STR$(PendingHours), _
N2) + RIGHT$(STR$(PendingMinutes), N2))
PendingValue# = VAL(PendingString$)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB ControlledInput (CBoxRow, CBoxColumn, CMessageRow, _
CMessageColumn, CLength, CMessageText$, CInputResponse$, _
NumlockRequest, CFilenameShow, CScreenBottomsShow, CHoldAtEnd) STATIC
'=========================================================================
' Accept Input, Given Location, Length, Prompt Message
DEFINT A-Z
SubnumSave = Subnum
Subnum = 17
'-------------------------------------------------------------------------
' Input/Output Call Parameters
' BoxRow,BoxColumn Placement Of Editing Field
' MessageRow,MessageColumn Placement Of Prompt Message
' MessageText$ Prompt Message
' Length Length Of Prompt Message
' InputResponse$ Returned Response (in Common)
' HoldAtEnd Hold Cursor at End Input
' NumlockRequest Change Value of Numlock (1=on, 0=off)
' FilenameShow Display Appointment Filename
' ScreenBottomsShow Display Screen Bottom Prompts
BoxRow = CBoxRow
BoxColumn = CBoxColumn
MessageRow = CMessageRow
MessageColumn = CMessageColumn
Length = CLength
MessageText$ = CMessageText$
FilenameShow = CFilenameShow
ScreenBottomsShow = CScreenBottomsShow
HoldAtEnd = CHoldAtEnd
InputResponse$ = CInputResponse$
'-------------------------------------------------------------------------
' Display Box For Input Value To Be Placed In
IF NumlockRequest THEN ' This will automatically
CALL KeyStuff(KeyNumOn) ' turn Insert off until
ELSE ' allowed
CALL KeyStuff(KeyNumOff)
END IF
AllowInsertMode = Yes
IF FilenameShow THEN CALL DisplayApptFilename
IF ScreenBottomsShow THEN CALL ScreenBottoms
InLength = LEN(InputResponse$)
IF InLength < Length THEN ' Pad out if too short
InputResponse$ = InputResponse$ + SPACE$(Length - InLength)
END IF
IF InLength > Length THEN ' or chop off if too long
InputResponse$ = LEFT$(InputResponse$, Length)
END IF
' Establish the Box
CALL ShowIt(N14, BoxRow, BoxColumn, (SPACE$(Length)))
'-------------------------------------------------------------------------
' Display The Initial Value Of Input And Prompt Message
IF NOT EchoSuppression THEN
CALL ShowIt(N0, N0, N0, InputResponse$)
ELSE
' Blanks
CALL ShowIt(N0, N0, N0, (Strng$(LEN(InputResponse$), N32)))
END IF
CALL ShowIt(N6, MessageRow, MessageColumn, MessageText$)
'-------------------------------------------------------------------------
' Place The Cursor, Set Character Position (J)
CALL Kolors(N14)
CursorRow = BoxRow
CursorColumn = BoxColumn
CALL KeyStuff(KeyCursor) ' Turn the cursor on
J = N1
'-------------------------------------------------------------------------
' Special Editing Keys
' Shift-Tab Goes To Left End Of Editing Field
' Shift-Return Goes To Right End Of Editing Field
' Shift-Delete Deletes Rest Of Editing Field From Cursor To End
'=========================================================================
' Next Keystroke Comes Back to Here
'=========================================================================
WordStart:
DisplayWholeWord$ = False$ 'Whole Word Instead of 1 Character
CursorIncremented = N0 'Cursor Moved After Character
IncrementCursor$ = False$ 'Request to Move Cursor Right
NormalKeystroke$ = False$ 'Character Entered Flag
'=========================================================================
KeyGet:
KeyTrapEnabled = Yes 'Enable Editing Key Trap
CALL KeyStuff(KeySingle) 'Move the Cursor/Get a Keystroke
KeyTrapEnabled = No 'Disable Editing Key Trap
'=========================================================================
SELECT CASE KeyShiftTrap ' Special Key Traps From Main Level
CASE 0 'None (0)
CALL Kolors(N14)
SELECT CASE LEN(Keystroke$) + N1'Regular Keystrokes
CASE 1 'No Keystroke
GOTO KeyGet
CASE 2 'Length One Keys
GOTO OneKeys
CASE 3 'Length Two Keys
GOTO TwoKeys
END SELECT
CASE 2 'Shift Tab (2)
'---------------------------------------------------------------
' Shift-Tab Goes To Left End Of Editing Field (also home)
KeyShiftTrap = N0
LeftEndOfField:
J = N1
CursorRow = BoxRow
CursorColumn = BoxColumn + J - N1
GOTO WordStart
CASE 3 'Shift Return (3)
'---------------------------------------------------------------
' Shift-Return Goes To Right End Of Editing Field (also end)
KeyShiftTrap = N0
RightEndOfField:
J = Length
CursorRow = BoxRow
CursorColumn = BoxColumn + J - N1
GOTO WordStart
CASE 4 'Shift Delete (4)
'---------------------------------------------------------------
' Shift-Delete Deletes Rest Of Editing Field From Cursor To End
KeyShiftTrap = N0
CALL Myd2(InputResponse$, J, Length - J + N1, _
(Strng$(Length - J + N1, N32)))
DisplayWholeWord$ = True$
IncrementCursor$ = False$
GOTO NewCharWholeWord
CASE 5 'Ctrl-Right-Arrow (5)
'---------------------------------------------------------------
' Ctrl-Right-Arrow Goes to Next Word
KeyShiftTrap = N0
IF MID$(InputResponse$, J, N1) = Blank1$ THEN 'Next Non-Blank
CALL MhNotInstr(Pointer%, J%, InputResponse$, N32)
IF Pointer THEN J = Pointer 'If Was Blank
ELSE
CALL MhInstr(Pointer%, J%, InputResponse$, Blank1$)
IF Pointer <> N0 AND Pointer <> Length THEN 'Next Blank
CALL MhNotInstr(Pointer%, (Pointer% + N1%), _
InputResponse$, 32) 'Then Next
IF Pointer THEN J = Pointer 'Non-Blank
END IF
END IF
CursorRow = BoxRow
CursorColumn = BoxColumn + J - N1
GOTO WordStart
CASE 6 'Ctrl-Left-Arrow (6)
'---------------------------------------------------------------
' Ctrl-Left-Arrow Goes to Previous Word
FirstNonBlankChar = No
KeyShiftTrap = N0
FromRightEnd = Length - J + N1 ' From Right End, Not Left
' Find Last non blk
IF MID$(InputResponse$, J, N1) = Blank1$ THEN
NowDoBlank:
CALL MhNotBackwardInstr(Pointer%, FromRightEnd%, _
InputResponse$, N32)
IF Pointer < N2 OR FirstNonBlankChar = Yes THEN
IF Pointer <> N0 THEN
J = Pointer
ELSE
J = N1
END IF
GOTO PrevWordDone
END IF
FromRightEnd = Length - Pointer + N1
END IF
CALL MhBackwardInstr(Pointer%, FromRightEnd%, _
InputResponse$, Blank1$) ' to next blank
SELECT CASE Pointer
CASE 0
J = N1
CASE IS = (J - N1)
IF FirstNonBlankChar THEN GOTO CaseElse
FirstNonBlankChar = Yes
FromRightEnd = FromRightEnd + N1
GOTO NowDoBlank
CASE ELSE
CaseElse:
J = Pointer + N1
END SELECT
PrevWordDone:
CursorRow = BoxRow
CursorColumn = BoxColumn + J - N1
GOTO WordStart
END SELECT
'=========================================================================
' Length One Keys--Take Action
'=========================================================================
OneKeys:
SELECT CASE InString(CHR$(Enter) + CHR$(Tabb) + CHR$(Bsp) + CHR$(Esc), _
RIGHT$(Keystroke$, N1))
CASE 1, 2, 4 'Enter, Tab, Esc Keys (Exits)
GOTO WordOut
CASE 3 'Back Space Key (Deletes Prev Char)
'---------------------------------------------------------------
'Backspace, If Beginning, Sound Bell, Otherwise Delete Char Left
IF J = N1 THEN
CALL MinorBeeper
GOTO WordStart
END IF
J = J - N1
CALL Myd2(InputResponse$, J, N1, Blank1$)
IncrementCursor$ = False$
IF Insrt% = N1 THEN ' If Insert Mode
GOSUB ShiftLeft ' Move String After Character
ELSE
DisplayWholeWord$ = False$' Else Delete Only Character
END IF
GOTO NewCharWholeWord
CASE ELSE 'Other Length One Keys (Normal Input)
'---------------------------------------------------------------
' Other Input Keys, Save Keystroke In Current Character Position
' If Insert Mode is On, Move String Right As Character Types
IF Insrt% = N1 THEN
GOSUB ShiftRight
DisplayWholeWord$ = True$
ELSE
DisplayWholeWord$ = False$
END IF
CALL Myd2(InputResponse$, J, N1, Keystroke$)
IncrementCursor$ = True$
NormalKeystroke$ = True$
GOTO NewCharWholeWord
END SELECT
'=========================================================================
' Length Two Keys--Take Action
'=========================================================================
TwoKeys:
SELECT CASE InString(CHR$(F1) + CHR$(West) + CHR$(East) + CHR$(Del) + _
CHR$(HomeKey) + CHR$(EndKey), RIGHT$(Keystroke$, N1))
CASE 1 'F1 (Exits)
GOTO WordOut
CASE 2 'West (Cursor Left)
'---------------------------------------------------------------
' West Moves Cursor Left One
IF J = N1 THEN
CALL MinorBeeper
ELSE
J = J - N1
CursorRow = BoxRow
CursorColumn = BoxColumn + J - N1
END IF
GOTO WordStart
CASE 3 'East (Cursor Right)
'---------------------------------------------------------------
' East Moves Cursor Right One
IF J = Length THEN
CALL MinorBeeper
ELSE
J = J + N1
CursorRow = BoxRow
CursorColumn = BoxColumn + J - N1
END IF
GOTO WordStart
CASE 4 'Delete (String Left)
'---------------------------------------------------------------
' Delete Moves Whole String Left One, Trailing A Space
GOSUB ShiftLeft
GOTO NewCharWholeWord
CASE 5 'Home (same as shift-tab)
'---------------------------------------------------------------
GOTO LeftEndOfField
CASE 6 'End (same as shift-return)
'---------------------------------------------------------------
GOTO RightEndOfField
CASE ELSE 'Error -- get another keystroke
'---------------------------------------------------------------
CALL MinorBeeper
GOTO WordStart
END SELECT
'=========================================================================
' New Character or Whole Word Display Comes Here
'=========================================================================
NewCharWholeWord:
IF DisplayWholeWord$ = True$ THEN
GOSUB WordShow 'Display Whole Word
DisplayWholeWord$ = False$
ELSE 'or
IF NOT EchoSuppression THEN
CALL ShowIt(N0, BoxRow, (BoxColumn + J - N1), _
(MID$(InputResponse$, J, N1))) 'Just One Character
ELSE 'or
CALL ShowIt(N0, BoxRow, (BoxColumn + J - N1), Blank1$)
' Blank if Suppressed
END IF
END IF
'-------------------------------------------------------------------------
IF IncrementCursor$ = True$ THEN
IF J < Length THEN 'Move Cursor, Don't Overrun Field
CursorIncremented = N1
J = J + N1
ELSE
CursorIncremented = N0
END IF
END IF
'-------------------------------------------------------------------------
' Place The Cursor In Its New Position
CursorRow = BoxRow
CursorColumn = BoxColumn + J - N1
'-------------------------------------------------------------------------
' Get Next Keystroke If Any Of The Following ---
IF HoldAtEnd OR J < Length OR NormalKeystroke$ = False$ OR _
(NormalKeystroke$ = True$ AND CursorIncremented = N1) THEN
GOTO WordStart
END IF ' Character at end of field gets out
'=========================================================================
' Get Out Here -- We're Finished
'=========================================================================
' No hold, F1, Enter, Tab, And Escape End It All
WordOut:
CALL Kolors(N7)
GOSUB WordShow ' At End, Display Whole Word
CALL Kolors(N6)
GOTO Finished
'-------------------------------------------------------------------------
' Reprint Entire Input Word And Reposition Cursor Where It Was
WordShow:
IF NOT EchoSuppression THEN
CALL ShowIt(N0, BoxRow, BoxColumn, InputResponse$)
ELSE
CALL ShowIt(N0, BoxRow, BoxColumn, _
(Strng$(LEN(InputResponse$), N32)))
END IF
RETURN
'---------------------------------------------------------------
'Insert Mode Moves Whole String Right One, Truncating, Inserts Space
ShiftRight:
IF J <> Length THEN
MID$(InputResponse$, J + N1, Length - J) = _ 'MhMidString made all
MID$(InputResponse$, J, Length - J) ' the characters the
END IF ' same as the 1st
CALL Myd2(InputResponse$, J, N1, Blank1$)
RETURN
'---------------------------------------------------------------
'Delete Moves Whole String Left One, Trails with Space
ShiftLeft:
IF J <> Length THEN
CALL MhMidString(InputResponse$, J%, Length% - J%, _
InputResponse$, J% + N1%)
END IF
CALL Myd2(InputResponse$, Length, N1, Blank1$)
DisplayWholeWord$ = True$
IncrementCursor$ = False$
RETURN
'-------------------------------------------------------------------------
Finished:
CInputResponse$ = InputResponse$
AllowInsertMode = No
CALL KeyStuff(KeyCursorOff) ' Turn Cursor Off
CALL KeyStuff(KeyNumOff) ' Turn Numlock Off
IF ScreenBottomsShow THEN CALL ScreenBottomsDelete
Subnum = SubnumSave
END SUB
'=========================================================================
SUB Credits (WhichLine) STATIC
'=========================================================================
' Phone Number, Address, Registration Fee or Owner
' Used by GenGreeting1 and EndItAll
DEFINT A-Z
SubnumSave = Subnum
Subnum = 139
AddressLine = WhichLine + N1
BoxEnd = WhichLine + N4
CopyLine = WhichLine + N5
IF ColorCRT THEN CALL Kolors(N3) ELSE CALL Kolors(N7)
CALL BoxDraw(N1, WhichLine, BoxEnd, N8, N38)
CALL BoxDraw(N1, WhichLine, BoxEnd, N48, N72)
CALL ShowMult(N6, AddressLine, N9, N29, N3)
CALL ShowMult(N6, AddressLine, N49, N23, N3)
CALL ShowIt(N6, AddressLine, N10, "11645 Charter Oak Ct., #201")
CALL ShowIt(N0, Nm1, N13, "Reston, VA 22090-4526")
CALL ShowIt(N0, Nm1, N16, "(703) 435-1110")
CALL ValidateUser (WhichLine)
IF ColorCRT THEN CALL Kolors(N4) ELSE CALL Kolors(N7)
CALL ShowIt(N0, CopyLine, Nm2, _
" Copyright (c) 1985-1990 by Paul Muñoz-Colman. All rights reserved. ")
Subnum = SubnumSave
END SUB
'=========================================================================
SUB DayDate (DateToIndex$) STATIC
'=========================================================================
' Find The Day Of The Week For A Date (DayDate)
' (DateToIndex$ in gives IndexedDay out)
' Good from Years 0001 to 9999
DEFINT A-Z
SubnumSave = Subnum
Subnum = 18
'-------------------------------------------------------------------------
' Appreciation to Herb Goertzel for his simple and brilliant piece of
' mathematics. Day of week is number of years (residues; 365 Mod 7 = One)
' plus leap year days plus current year days, modulo 7, plus 1.
'-------------------------------------------------------------------------
Year = VAL(MID$(DateToIndex$, N1, 4)) 'The Year
Month = VAL(MID$(DateToIndex$, 5, N2)) 'The Month
Day = VAL(MID$(DateToIndex$, N7, N2)) 'The Day
'-------------------------------------------------------------------------
' For The Current Year, Count Leap Year Day If Necessary
' If This Isn't A Leap Year or Before March, Don't Count Leap Year Day
' If Before March Don't Count Feb 29th Because It's Included in "Day"
IF Month < N3 THEN
LeapYearDay = N0 'Then don't count leap year
ELSE
LeapYearDay = Leap(Year) 'Else count it
END IF
'-------------------------------------------------------------------------
' Now Count The Number of Year Residues and Add In Past Leap Year Days
Prioryears = Year - N1
PriorYearsWLeaps = Prioryears + INT(Prioryears / 4) + _
INT(Prioryears / 400) - INT(Prioryears / 100) ' - Every 100th Year
PriorYearsLeaps = PriorYearsWLeaps - Prioryears ' except 400th
PriorYearsDays& = Prioryears * 365&
'-------------------------------------------------------------------------
' Now Add the Days This Year Into The Total (Also Do The Julian Date)
' Total = Residue + Prior Months + This Month + Leap Year
AllWLeaps = PriorYearsWLeaps + JulianDays(Month) + Day + LeapYearDay
JulianDate& = AllWLeaps - PriorYearsWLeaps + 1000& * (Year MOD 100)
'-------------------------------------------------------------------------
' Take The Whole Thing Modulo 7 and Make Non-Zero
' (If the calendar had started in the year 0000, Jan 1, 0000 would
' arithmetically have been a Saturday!)
IndexedDay = N1 + AllWLeaps MOD N7
CountedDay& = AllWLeaps - Prioryears + 365 + PriorYearsDays&
'-------------------------------------------------------------------------
IF Year = N0 AND Month = N1 AND Day = N1 THEN
IndexedDay = N7
JulianDate& = N1
CountedDay& = N0
END IF
'-------------------------------------------------------------------------
Subnum = SubnumSave
END SUB
'=========================================================================
FUNCTION DirectoryExist(DirectoryName$) STATIC
'=========================================================================
' To See if a Directory Exists -- Using MhDir & MhDirExist
DEFINT A-Z
SubnumSave = Subnum
Subnum = 142
IF LEN(DirectoryName$) = N3 AND MID$(DirectoryName$,N2) = ":\" THEN
Drive = ASC(DirectoryName$) - N64 'If root, then
Temp$ = SPACE$(66) 'can't use
CALL MhDir(N1%, Drive%, Temp$, NoSuchDir%) 'MhDirExist
Temp$ = Blank0$
ELSE
CALL MhDirExist((ASCIIZ$(DirectoryName$)), NoSuchDir%)
END IF
IF NoSuchDir THEN
DirectoryExist = No
ELSE
DirectoryExist = Yes
END IF
Subnum = SubnumSave
END FUNCTION
'=========================================================================
SUB DirectReturnCheck STATIC
'=========================================================================
' To See If Event Table Is Stable When Returning To Main Menu
' So Prompt for Returning To Clock Screen Can Be Pressent
DEFINT A-Z
SubnumSave = Subnum
Subnum = 19
IF EventTableStable THEN
DirectReturn = Yes
Menu1 = MainMenuLastEntry
IF NOT ApptFile THEN CALL OpenAppts
ELSE
DirectReturn = No
END IF
Subnum = SubnumSave
END SUB
'=========================================================================
SUB DisplayApptFilename STATIC
'=========================================================================
' Show the name of the Appointment File on the Menus
DEFINT A-Z
SubnumSave = Subnum
Subnum = 20
IF ApptFilename$ <> Blank8$ THEN
CALL ShowIt(N13, N1, N64, " File ")
CALL ShowIt(N6, N0, Nm1, (SPACE$(N10)))
CALL ShowIt(N14, N0, N0, Blank1$)
CALL GetFilenameLength
CALL ShowIt(N0, N0, Nm1, _
(MID$(ApptFilename$, N1, FilenameLength)))
CALL ShowIt(N0, N0, Nm1, Blank1$)
END IF
Subnum = SubnumSave
END SUB
'=========================================================================
SUB DOSBIOSServices STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 138
' All DOS ROM BIOS Services come here
' All variables are in COMMON SHARED
CALL MhDos2(DosEcode%, InterruptNumber%, _
ES%, SI%, DI%, AH%, AL%, BH%, BL%, CH%, CL%, DH%, DL%)
IF DosEcode% THEN
ERROR 255
END IF
Subnum = SubnumSave
END SUB
'=========================================================================
SUB DoShell (ShellCommand$) STATIC
'=========================================================================
' All DOS Shells are Done From Here / Pass the Parameter /
DEFINT A-Z
SubnumSave = Subnum
Subnum = 21
CALL Kolors(N99)
' Ditch Trailing Blanks in Command
ShellCommand$ = RTRIM$(ShellCommand$)
IF MemoryResident THEN
SrShellCommand$ = ShellCommand$
ToShellCommand$ = ShellCommand$ + CHR$(N13%)
CALL SrResidentShell(ToShellCommand$, ShellEcode%)
IF ShellEcode THEN
CALL SrCancelShell 'Cancel Shell if Error
Ecode = ShellEcode
ERROR 254
ELSE
MemoryResidentShell = Yes
END IF
CALL StayResPopDown
CALL SrCancelShell
MemoryResidentShell = No
ELSE
CALL SetVideoMode(N1)
CALL SetVideoPage(N1)
CALL RestoreDOSKeyState 'Set DOS Ins,Caps,Num,Scroll
LOCATE N3, N1, N1, InsertCursorStart, CursorStop' Set Cursor At Top
CALL SetCurrentDirectory(N0) ' Set User Directory
IF ShellCommand$ <> Blank0$ THEN ' Since Shell Won't
SHELL (ShellCommand$) ' Turn it Off
ELSE
SHELL
END IF
CALL SaveCurrentDirectory(N0) ' Save User Directory
CALL SetCurrentDirectory(N1) ' Set Calendar Directory
CALL SaveDOSKeyState 'Save DOS Ins,Caps,Num,Scroll
CALL SetVideoMode(N0)
CALL SetVideoPage(N0)
CALL RestoreCalKeyState 'Restore CAL Ins,Caps,Num,Scroll
END IF
Subnum = SubnumSave
END SUB
'=========================================================================
SUB DOSShell (DOSEntry) STATIC
'=========================================================================
' Run a Temporary DOS Session
DEFINT A-Z
SubnumSave = Subnum
Subnum = 22
CommandError$ = False$
SELECT CASE DOSEntry
CASE 0 ' From Menu
BuildMenu:
MenuLines(N1) = "Execute DOS Session and Return"
MenuLines(N2) = "Execute Stored DOS Command and Return"
MenuLines(N3) = "Change Stored DOS Command"
ClockScreen = No
OnEditPage = No
CALL ClearScreenNormal(N1)
ScreenTitles$(N1) = "Select Type of DOS Session to Execute"
CALL Titles(N1)
CALL ShowIt(N6, N12, N1, "Stored DOS Command Is --")
IF DOSCommand$ = Blank80$ THEN
CALL ShowIt(N7, N13, N1, "(No Command Stored)")
ELSE
CALL ShowIt(N7, N13, N1, DOSCommand$)
END IF
IF CommandError$ = True$ THEN
CALL PrepareforMessage
CALL ShowIt(N0, N0, N0, _
"DOS Command Is Blank -- Change If Desired")
CommandError$ = False$
DOSType = N3
END IF
CALL MenuDriver(N3, DOSType, N6, Nm1, No, N0, N1, N1)
CALL BlankError
IF MenuExit = MenuCancelled THEN
CALL ClearScreenNormal(N1)
CALL DirectReturnCheck
GOTO ExitPoint3
END IF
PopCheckTime:
IF DOSType <> N3 THEN
TimerDisplaySuppress = Yes
IF MemoryResident AND PoppedUpOverProgram THEN
ErrorLine1$ = _
"Can't Execute DOS Session/Command If Loaded Before Another Program"
ERROR 253
END IF
CALL Kolors(N99)
CLS
END IF
SELECT CASE DOSType
CASE 1 ' DOS Shell
IF NOT MemoryResident THEN
ScreenRow = N1
GOSUB ReturnPrep ' Return Instructions
GOSUB Return2 ' Type Exit Instructions
END IF
CALL DoShell(Blank0$) ' Go Do The DOS Session
CASE 2 ' DOS Command
IF DOSCommand$ = Blank80$ THEN
CommandError$ = True$
GOTO BuildMenu
END IF
CALL DoShell(DOSCommand$)
IF NOT MemoryResident THEN
ScreenRow = N1
GOSUB ReturnPrep ' Return Instructions
GOSUB ReturnPause ' Pause Instructions
END IF
CASE 3 ' Change DOS Command
CALL ControlledInput(N13, N1, N12, N1, N80, _
"Enter DOS Command to Store Below --", DOSCommand$, N0, N1, N1, N1)
CALL WriteCalDOS
GOTO BuildMenu
END SELECT
CASE 1 ' F6 For DOS Shell
DOSType = N1
GOTO PopCheckTime
CASE 2 ' F7 For DOS Command
DOSType = N2
GOTO PopCheckTime
END SELECT
CALL DirectReturnCheck
CALL ClearScreenNormal(N1)
GOTO ExitPoint3
ReturnPrep:
' Show Band for Instructions
CALL ShowErase(N13, N1, N1, N80, Blank0$)
RETURN
ReturnPause:
' Issue Returning Instructions
CALL ShowIt(N7, N1, Nm2, _
" Press a Key to Return to Personal Calendar ... ")
CALL KeyStuff(KeyWait)
RETURN
Return2:
' Issue Pause Instructions and Wait
CALL ShowIt(N7, N1, Nm2, _
" To Return to Personal Calendar, Type EXIT Then Press Return ")
RETURN
ExitPoint3:
Subnum = SubnumSave
END SUB
'=========================================================================
SUB EndItAll STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 105
' (From Ctl-Esc or Ctl-Break or Esc from main menu)
CALL SetCurrentDirectory(N1) ' Return to calendar's directory
IF MemoryResident THEN
IF PoppedUpOverProgram THEN
ErrorLine1$ = _
"Can't Quit Unless Last In Memory and Over DOS; Pop Down (F10) Instead"
ERROR 253 ' Return to Main Menu
END IF
END IF
CALL CloseFiles
CALL ClearOverdueTable
CALL ClearScreenNormal(N0)
CALL BoxDraw(N2%, N1%, N24%, N1%, N80%)
CALL BigChars(N3%, N6%, "Thank you for using")
CALL Kolors(N7)
CALL BigChars(N8%, N6%, "Personal Calendar--")
CALL Kolors(N6%)
CALL Credits(N18)
DO ' Clear keystroke buffer
LOOP WHILE LEN(INKEY$)
IF ColorCRT THEN CALL Kolors(N3) ELSE CALL Kolors(N7)
IF MemoryResident THEN
' Do a TSR Unload
' (remove program from memory).
CALL BigChars(N13%, N6%, "Removed from memory")
IF SrDiskSwapped THEN
CALL ShowIt(N6, N17, Nm2, "(And Deleted Disk Swap Files)")
END IF
CALL Kolors(N99)
CALL Snooze(1.7!) ' Pause before screen restore
CALL SetVideoMode(N1) ' and mode
CALL SetVideoPage(N1) ' Set User Page
GOSUB RestoreKeys ' Restore Keys and Cursor
Subnum = SubnumSave
'====================================================================
CALL SrReleaseMem(RelEcode%) ' Resident Program Exit
'====================================================================
' ONLY COMES HERE IF MEMORY RELEASE IS NOT SUCCESSFUL
'--------------------------------------------------------------------
Ecode = RelEcode
IF Ecode = N7 THEN
FatalError = No
IF ApptFile THEN
DirectReturn = Yes
Menu1 = MainMenuLastEntry
CALL OpenAppts ' Reopen Appts
END IF
ELSEIF Ecode THEN
FatalError = Yes
END IF
ERROR 254 ' Return to main menu
ELSE
' Non Memory-Resident Exit comes here.
IF UserMode <> CalMode OR _ ' If not going back to
DOSCursorPage <> ScreenPage THEN
HardSnooze = Yes ' same page or mode, pause
CALL Snooze(1.7!) ' so user can read farewell
ELSE
CALL Kolors(N99)
END IF
CALL SetVideoMode(N1) ' and mode
CALL SetVideoPage(N1) ' Set User Page
GOSUB RestoreKeys ' Restore Keys and Cursor
'====================================================================
SYSTEM ' Non-Resident Program Exit
'====================================================================
END IF
' Program Never Terminates Here
RestoreKeys:
CALL RestoreDOSKeyState
LOCATE 24, N1, N1, InsertCursorStart, CursorStop' Normal DOS Cursor
RETURN
RestoreState:
RETURN
END SUB
'=========================================================================
SUB ErrorHandler STATIC
'=========================================================================
DEFINT A-Z
Suberror = Subnum ' Save SUB that was in error
Subnum = 23
DO ' Hard clear of keystroke buffer
LOOP WHILE LEN(INKEY$)
ErrorNumber = ERR ' Save error number
ToShow = ErrorNumber
MhEcode = Ecode
LastErrorMessage = 269 ' Set last stored error message limit
IF ErrorNumber = 253 THEN ' Remove attempts
FatalError = No ' Or pop attempts when
ClockScreen = No ' locked into memory
InHelp = No
OnEditPage = No
CALL ClearScreenNormal(N1) ' Write Error Message
CALL DirectReturnCheck ' and return to main menu
CALL PrepareforMessage
CALL ShowIt(N0, N0, N0, ErrorLine1$)
ErrorMessageToWrite = No
GOTO ExitPoint4
END IF
IF ErrorNumber = N0 THEN GOTO ExitPoint4 ' If no error, get out
' Error Handling
ScreenRow = ErrMsgPlacement
IF ErrorNumber = 254 OR ErrorNumber = 255 THEN
ToShow = MhEcode ' Stay-Res or Mach 2
FatalError = No
END IF
IF FatalError THEN ' Event safety
CALL CloseFiles
EventTableStable = No
END IF
IF FileExist("calerror.dat") THEN ' Get SUB Name
OPEN "R", FilenumError, "calerror.dat", N80
FIELD FilenumError, N80 AS HelpErrorBuffer$
' Starting at rec 270 in CALERROR.DAT are module numbers &
' procedure names for trace (270 is main program)
GET #FilenumError, LastErrorMessage + 1 + Suberror
JJ = LastErrorMessage ' Get Number of Last Record
ELSE
JJ = N0
END IF
IF JJ THEN ' Construct Message
ErrorLine1Base$ = " Error" + STR$(ToShow) + _
" Detected In Procedure '" + RTRIM$(MID$(HelpErrorBuffer$, _
N2, LEN(HelpErrorBuffer$) - N1)) + "' of module CAL" + _
LEFT$(HelpErrorBuffer$, N1) + ":"
ELSE
ErrorLine1Base$ = " Error" + STR$(ToShow) + _
" Detected, But Error Message File CALERROR.DAT Does Not Exist"
END IF
IF ErrorNumber > 253 THEN
' MicroHelp Errors
SELECT CASE ErrorNumber
CASE 255 'Mach 2 Errors
SELECT CASE MhEcode ' Computer Error Message Loc
CASE 1 TO 254 ' In File
ErrorNumber = MhEcode + 250' Crits Start at 251
CASE 255
ErrorNumber = 250 ' Except 255 which at 250
CASE IS > 256
ErrorNumber = MhEcode - 156' Non Crits start 101
CASE ELSE
ErrorNumber = 500 ' Beyond End Of File
END SELECT
CASE 254 'Stay-Res Plus Errors
IF StartupScreenHold THEN EarlyPopDownFailed = Yes
ErrorNumber = MhEcode + 200 ' Stay-Res is 200 to 215
END SELECT
ErrorLine1$ = "MicroHelp" + ErrorLine1Base$
ELSE
' Microsoft Errors
ErrorLine1$ = "BASIC" + ErrorLine1Base$
END IF
IF ErrorNumber <= JJ OR JJ = N0 THEN
GET FilenumError, ErrorNumber
IF HelpErrorBuffer$ = SPACE$(N80) OR JJ = N0 THEN
ErrorLine2$ = "(No Error Text Available)"
ELSE
ErrorLine2$ = HelpErrorBuffer$
END IF
END IF
ErrorMessageToWrite = Yes
IF FatalError THEN
CALL CloseFiles
ELSE
CLOSE FilenumError
END IF
IF PrimitiveState THEN ' here, we're preparing for a
PRINT
PRINT ErrorLine1$ ' about 50-60 bytes to the stack
PRINT ErrorLine2$
PRINT
PRINT "Program initialization is incomplete. Cannot proceed."
SYSTEM
END IF
ErrorNumber = N0
ExitPoint4:
CALL SetCurrentDirectory(N1) ' Set Program Directory
' Check video lines and reset
CALL SetVideoMode(N0) ' set calendar mode
CALL SetVideoPage(N0) ' and page
AllowInsertMode = No ' Turn off insert mode
AutoStarted = No ' Turn off autostart
SrAutoPopDown = No
SrAutoPopDownReady = No
SrAutoPopDownHappened = No
ClockScreen = No ' Set in menu, not anything else
OnEditPage = No
InHelp = No
OnOverduePage = No
EditingEvents = No ' Turn off event edit
EditingNotes = No
InPopDown = No ' Turn off popping down
LoopCounterShow = Yes ' Set debug counter on
MenuChoice = N1 ' Set main menu to top
MenuSingleLine = No ' Reset menu driver
WhichColor = N0
CursorState = N0
IF FatalError THEN DirectReturn = No
LOCATE CursorRow, CursorColumn, CursorState ' Turn off cursor
Subnum = Suberror
END SUB
'=========================================================================
SUB EscapeLine STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 24
CALL EscapeLineDelete
CALL ShowIt(N7, N25, N43, " Esc ")
CALL ShowIt(N6, N0, Nm1, "Return")
Subnum = SubnumSave
END SUB
'=========================================================================
SUB EscapeLineDelete STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 25
CALL ShowErase(N6, N25, N43, N19, Blank0$)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB EventErrorMessage STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 26
IF ReturnMessage$ <> Blank0$ THEN ' Limit Message Length
WindowLength = LEN(EditInstructions(N1, N1))
IF LEN(ReturnMessage$) > WindowLength THEN
ReturnMessage$ = LEFT$(ReturnMessage$, WindowLength)
END IF
StartColumn = (WindowLength - LEN(ReturnMessage$)) \ N2
' Compute and Locate Position
CALL ShowIt(N16, N22, StartColumn, ReturnMessage$)
ReturnMessage$ = Blank0$ ' Blank Message After Display
END IF ' to Prevent Repeated Display
Subnum = SubnumSave
END SUB
'=========================================================================
FUNCTION FileExist(ExistFilename$) STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 120
CALL MhFileExist((ASCIIZ$(ExistFilename$)), ExistEcode%)
IF ExistEcode THEN
FileExist = No
ELSE
FileExist = Yes
END IF
Subnum = SubnumSave
END FUNCTION
'=========================================================================
SUB FileFormat STATIC
'=========================================================================
DEFINT A-Z
SubnumSave = Subnum
Subnum = 27
'
' EXIT FROM PROGRAM IS STOPPED FROM FILE CHANGE TO OPTIONS RESET!
'
' Change File Based On Size -- Called From Options Menu Now
' NumberofEvents and Notes Is Already Updated to New Value
' OldNumberEvents and Notes Has Previous Values
ExitKeys = No
SELECT CASE WhichExpansion$
CASE "e"
OldNumber = OldNumberEvents ' Expand Events
NewNumber = NumberofEvents
PrintLabel$ = "Events"
CASE False$
OldNumber = OldNumberNotes ' Expand Notes
NewNumber = NumberofNotes
PrintLabel$ = "Notes"
CASE ELSE
ExitKeys = Yes
GOTO ExitPoint5
END SELECT
' Display Warning Notice
CALL MinorBeeper
CALL Kolors(N6)
CALL ClearLast4 ' Changing ... on line 23
' Compressing ... on line 24
' Moving ... on line 25
CALL ShowMult(N14, N23, N1, N80, N3)
Lin$ = "Please Wait--Changing Appointment File Size From" + _
STR$(OldNumber) + " To" + STR$(NewNumber)
IF WhichExpansion$ = "e" THEN
Lin$ = Lin$ + " Events"
ELSE
Lin$ = Lin$ + " Notes"
END IF
CALL ShowIt(N0, N23, N8, Lin$)
Excess = ABS(NewNumber - OldNumber)
IF (NewNumber - OldNumber) < N0 THEN
' Shrink File
CompressFile = N1 ' Compress Excess
' Move Excess to History unless Events and Arrays Null From Prior Move
IF WhichExpansion$ = False$ OR EventTableStable THEN
IF WhichExpansion$ = "e" THEN
' Shrink Events
' Copy Excess Events to History
EventtoHistory = Yes
ELSE
EventtoHistory = No
END IF
Lin$ = "Moving Last" + STR$(Excess) + Blank1$ + PrintLabel$ + _
" to History"
FOR I = Excess TO N1 STEP Nm1
CALL KeyStuff(KeyStatus)
IF WhichExpansion$ = "e" THEN
WhichEvent = OldNumberEvents - I + N1
CALL ApptToMenu(N1)
HistoryBuffer$ = CurrentEventLine$
ELSE
Pointer = StartingNote + OldNumberNotes - I
CALL GetApptRecord(Pointer)
HistoryBuffer$ = ApptBuffer$
END IF
CALL WritetoHistory
Lin1$ = Lin$ + STR$(I - N1) + SPACE$(4)
CALL ShowIt(N14, N24, N8, Lin1$)
NEXT
END IF
' Move Notes and History Back In File
Lin$ = " Moving "
IF WhichExpansion$ = "e" THEN Lin$ = Lin$ + "Notes/"
Lin$ = Lin$ + "History Backward In File"
CALL ShowErase(N0, N24, N1, N80, Lin$)
EOFRecord = LOF(FilenumAppt) \ N80
IF WhichExpansion$ = "e" THEN
MoveStart = StartingNote
ELSE
MoveStart = StartingHistory
END IF
CALL MoveApptRecords(N1, MoveStart, EOFRecord, N1, _
N0, -Excess, N1, N0, N0)
ELSE
' Expand File
CompressFile = N0 ' Don't Compress
EOFRecord = LOF(FilenumAppt) \ N80
CALL ShowErase(N0, N24, N1, N80, Blank0$)
IF WhichExpansion$ = "e" OR StartingHistory < EOFRecord THEN
Lin$ = "Moving "
IF WhichExpansion$ = "e" THEN
Lin$ = Lin$ + "Notes/"
MoveEnd = StartingNote
ELSE
MoveEnd = StartingHistory
END IF
Lin$ = Lin$ + "History Forward" + STR$(Excess) + " In File"
CALL ShowIt(N0, N24, N8, Lin$)
' Move the Records
CALL MoveApptRecords(N1, EOFRecord, MoveEnd, Nm1, N0, _
Excess, N1, N0, N0)
' Blank the New Area
' This is done separately, because there could be far fewer
' records to move then to clear in the new area
CALL ShowErase(N0, N24, N1, N80, _
" Clearing Area For New Records")
CALL MoveApptRecords(N1, MoveEnd, MoveEnd + _
Excess - N1, N1, N0, N0, N0, N1, N0)
CALL ShowErase(N0, N24, N1, N80, Blank0$)
END IF
END IF
IF CompressFile = N1 THEN CALL CompressApptFile(Excess)
IF WhichExpansion$ = "e" THEN
EventSizeCode$ = MID$(ValidSizes$, (NewNumber \ 20), N1)
ELSE
NoteSizeCode$ = MID$(ValidSizes$, (NewNumber \ 20), N1)
END IF
CALL SetArrays
CALL SetOptions
ExitKeys = Yes
' Set Options To Expanded
ExitPoint5:
Subnum = SubnumSave
END SUB
'=========================================================================
SUB FileList STATIC
'=========================================================================
' Display a List of Saved Appointment Files
DEFINT A-Z
SubnumSave = Subnum
Subnum = 106
CALL ClearScreenNormal(N1)
ScreenTitles$(N1) = "Saved Appointment Files"
CALL Titles(Nm1)
CALL Kolors(N6)
CursorRow = N6
CursorColumn = N1
CALL KeyStuff(KeyCursorOff) ' Position Cursor for FILES
ErrorSwitch = No
CALL FileListGet ' for error handling in CAL1
IF ErrorSwitch THEN
ErrorSwitch = No
CALL ShowIt(N7, N15, Nm2, " There Are No Saved Appointment Files ")
Menu1 = MainMenuCreate
END IF
' Clear DOS prompt and give one of our own
CALL ClearLast3
CALL ScreenBottoms
CALL ReturnLineDelete
CALL KeyStuff(KeyWait) ' Wait for a keystroke
CALL ClearScreenNormal(N1)
CALL DirectReturnCheck
Subnum = SubnumSave
END SUB
'=========================================================================
SUB GenerateGreeting (GrLines) STATIC
'=========================================================================
' Generate Main Menu Greeting Lines
DEFINT A-Z
SubnumSave = Subnum
Subnum = 28
ScreenTitles$(N1) = "Personal Calendar (PC) for DOS"
ScreenTitles$(N2) = "Version " + ProgramVersion$
ScreenTitles$(N3) = "Main Menu" ' Shown Optionally
CALL Titles(GrLines)
Subnum = SubnumSave
END SUB
'=========================================================================
SUB GenGreetingScreen1 STATIC
'=========================================================================
' Generate Startup Screen
DEFINT A-Z
SubnumSave = Subnum
Subnum = 119
CALL Kolors(N6)
CALL BoxDraw(N2, N1, N25, N1, N80)
IF RIGHT$(ProgramVersion$, N1) = "ß" THEN 'Beta Warning
CALL MinorBeeper
CALL ShowIt(N9, N2, Nm2, _
" Beta Release -- You may not distribute without my permission !! ")
END IF
CALL Kolors(N7)
CALL BigChars(N3%, N10%, "Personal Calendar")
CALL Kolors(N6)
CALL BigChars(N8%, N22%, "PC for DOS")
IF ColorCRT THEN CALL Kolors(N3) ELSE CALL Kolors(N7)
CALL BigChars(N13%, N18%, "Version " + ProgramVersion$)
CALL Credits(N18)
CALL ShowIt(N7, N24, Nm2, "Press a Key to Continue ...")
Subnum = SubnumSave
END SUB
'=========================================================================
SUB GetFilenameLength STATIC
'=========================================================================
' Get the Length of the Appointment File Name
DEFINT A-Z
SubnumSave = Subnum
Subnum = 29
FilenameLength = InString(ApptFilename$, Blank1$) - N1
IF FilenameLength <= N0 THEN FilenameLength = 8
Subnum = SubnumSave
END SUB
'=========================================================================
SUB GetOptions STATIC
'=========================================================================
' Get Option Variables From Option Record
DEFINT A-Z
SubnumSave = Subnum
Subnum = 30
CALL GetApptRecord(N1)
ApptMasterRec$ = ApptBuffer$
' Pos 1-8 Password
ApptPassword$ = MID$(ApptMasterRec$, N1, 8)
' Pos 9 Footer Size
FooterSize = VAL(MID$(ApptMasterRec$, 9, N1))
IF FooterSize < N3 OR FooterSize > 9 THEN FooterSize = 5
' Pos 10 Alarm Initial Condition
InitialSound$ = MID$(ApptMasterRec$, 10, N1)
IF VAL(InitialSound$) THEN
SoundLevel = VAL(InitialSound$)
ELSE
' Old Sound Levels
IF InitialSound$ = True$ THEN SoundLevel = 4
IF InitialSound$ = False$ THEN SoundLevel = N1
END IF
' Pos 11 Size Of Note Area
NoteSize = VAL(MID$(ApptMasterRec$, 11, N1))
IF NoteSize < N0 OR NoteSize > (FooterSize - N1) THEN NoteSize = N2
' Pos 13 Print,Copy History
IncludeHistory$ = MID$(ApptMasterRec$, 13, N1)
IF IncludeHistory$ = True$ THEN InclHistory = Yes ELSE InclHistory = No
' Pos 14 Print,Copy Notes
IncludeNotes$ = MID$(ApptMasterRec$, 14, N1)
IF IncludeNotes$ = True$ THEN InclNotes = Yes ELSE InclNotes = No
' Pos 15 Allow Weekends On Daily
WeekendScheduling$ = MID$(ApptMasterRec$, 15, N1)
' Pos 16 Number of Events
EventSizeCode$ = MID$(ApptMasterRec$, 16, N1)
IF EventSizeCode$ = Blank1$ THEN EventSizeCode$ = LEFT$(ValidSizes$, N1)
' Pos 17-18 Event Look-Ahead (Defaults to 5 if blank)
Pending = VAL(MID$(ApptMasterRec$, 17, N2))
IF MID$(ApptMasterRec$, 17, N2) = SPACE$(N2) THEN Pending = 5
' Pos 19 Selected IBM "I" or Epson "E" Printer or "P" HPIIP or "N"one
SelectedPrinter$ = MID$(ApptMasterRec$, 19, N1)
IF SelectedPrinter$ = Blank1$ THEN SelectedPrinter$ = "-"
' Pos 20 Week Break on ASCII File or Print
WeekBreak$ = MID$(ApptMasterRec$, 20, N1)
IF WeekBreak$ = Blank1$ THEN WeekBreak$ = True$
' Pos 21 60 Notes "e"
NoteSizeCode$ = MID$(ApptMasterRec$, 21, N1)
IF NoteSizeCode$ = Blank1$ THEN
NoteSizeCode$ = MID$(ValidSizes$, (NumberofNotes \ 20), N1)
END IF
' Pos 22-23 Printer page line limit
PrinterLineLimit = VAL(MID$(ApptMasterRec$, 22, N2))
' Pos 24 Printer pause indicator
PrinterPause$ = MID$(ApptMasterRec$, 24, N1)
IF PrinterPause$ = Blank1$ THEN PrinterPause$ = False$
'-------------------------------------------------------------------------
' Set Printer Array
FOR I = N1 TO 50
CALL KeyStuff(KeyStatus)
SELECT CASE SelectedPrinter$
CASE "I"
PrinterCodes(I) = IBMCodes(I)
CASE "E"
PrinterCodes(I) = EpsonCodes(I)
CASE "P"
PrinterCodes(I) = HPIIPCodes(I)
CASE "4"
PrinterCodes(I) = I4019Codes(I)
CASE ELSE
EXIT FOR
END SELECT
NEXT
'-------------------------------------------------------------------------
Subnum = SubnumSave
END SUB
'=========================================================================
SUB Help STATIC
'=========================================================================
' HELP!!!
DEFINT A-Z
SubnumSave = Subnum
Subnum = 108
ErrorSwitch = No
ScreenSize = 20
InHelp = Yes
IF NOT FileExist("calhelp.dat") THEN
InHelp = No
CALL PrepareforError
CALL ShowIt(N0, N0, N0, _
"The Help Information File CALHELP.DAT Was Not Found Or Is Defective")
GOTO HelpExit
END IF
OPEN "R", FilenumHelp, "calhelp.dat", N80
FIELD FilenumHelp, N80 AS HelpErrorBuffer$
LastRecord = LOF(FilenumHelp) \ N80 'Last Record Number
LastPage = N1 + ((LastRecord - N1) \ ScreenSize)'Last Page
CurrentRecord = N1
CurrentPage = N1
' Start New Page
NewHelpPage:
CALL ClearScreenNormal(N0)
CALL ScreenBottoms
CALL ReturnLineDelete
CALL KeyStuff(KeyStatusAbs)
CurrentRecord = N1 + (CurrentPage - N1) * ScreenSize
CALL ShowIt(N6, N21, N1, (Strng$(N80, 196))) ' horizontal solid line
CALL ShowIt(N7, N23, N1, "*,Print")
CALL ShowIt(N6, N0, Nm1, " Print Help Text")
IF CurrentRecord > ScreenSize THEN
CALL ShowIt(N7, N24, N1, "PgUp")
CALL ShowIt(N6, N0, Nm1, " Previous Page")
CALL ShowIt(N7, N0, N27, "Home")
CALL ShowIt(N6, N0, Nm1, " 1st Page")
END IF
IF CurrentPage < LastPage THEN
CALL ShowIt(N7, N25, N1, "PgDn")
CALL ShowIt(N6, N0, Nm1, " Next Page")
CALL ShowIt(N7, N0, N27, "End")
CALL ShowIt(N6, N0, Nm1, " Last Page")
END IF
CALL ShowIt(N6, N22, N63, "Page")
CALL ShowIt(N0, N0, Nm1, _
(STR$(CurrentPage) + " of" + STR$(LastPage)))
CALL ShowIt(N7, Nm2, N63, "Ins")
CALL ShowIt(N6, N0, Nm1, " Specific Page")
' Get Next Record
GetHelpRecord:
GET FilenumHelp, CurrentRecord
' Set Screen Position
ScreenPosition = (CurrentRecord - N1) MOD ScreenSize
CALL ShowIt(N0, (ScreenPosition + N1), N1, HelpErrorBuffer$)
' End File or End Page
IF CurrentRecord < LastRecord AND _
(CurrentRecord MOD ScreenSize) <> N0 THEN
CurrentRecord = CurrentRecord + N1
GOTO GetHelpRecord
END IF
NextHelpKey:
CALL KeyStuff(KeyWait) ' Wait for a keystroke
SELECT CASE LEN(Keystroke$)
CASE 1 ' Length 1 Keys (Esc,Prnt)
SELECT CASE InString(CHR$(Esc) + CHR$(Prnt), _
RIGHT$(Keystroke$, N1))
CASE 1 ' Esc Key
CLOSE FilenumHelp
InHelp = No
CALL ClearScreenNormal(N1)
CALL ScreenBottoms
CALL DirectReturnCheck
GOTO HelpExit
CASE 2 ' Prnt Key
' Print Help Text
LprintTerminate = No
CALL InitPrinter 'Initialize Printer
FOR JJ = N1 TO LastRecord
IF LprintTerminate THEN EXIT FOR
' On Page Break
IF ((JJ - N1) MOD ScreenSize) = N0 THEN
PageNumber = N1 + ((JJ - N1) \ ScreenSize)
CALL ClearScreenNormal(N0)
CALL ScreenBottoms
CALL ShowIt(N7, N24, N1, _
"Printing Help File Text -- Please Wait")
CALL ShowIt(N0, Nm1, N1, ("Page" + _
STR$(PageNumber) + " of" + _
STR$(LastPage)))
IF PageNumber MOD N2 = N1 THEN
IF JJ <> N1 THEN
CALL PageEject
END IF
ELSE
CALL LprintString(Blank1$, N0)
END IF
CALL LprintString(Blank1$, N0)
' hyphens
CALL LprintString(Strng$(N80, N45), N0)
PrintString$ = "Personal Calendar (PC) " + _
"for DOS, version " + ProgramVersion$ + _
", Help File Text, Page" + _
STR$(PageNumber)
CALL LprintString(PrintString$, N0)
CALL LprintString(Strng$(N80, N45), N0)
CALL LprintString(Blank1$, N0)
END IF
GET FilenumHelp, JJ
Buffer80$ = HelpErrorBuffer$
CALL KeyStuff(KeySingle)
IF Keystroke$ = CHR$(Esc) THEN EXIT FOR
CALL LprintString(Buffer80$, N0)
ScreenPosition = (JJ - N1) MOD ScreenSize
CALL ShowIt(N6, (ScreenPosition + N1), N1, _
Buffer80$)
NEXT
IF NOT LprintTerminate THEN
CALL PageEject
LprintJobOver = Yes
CALL LprintString(Blank0$, N0)
ELSE
LprintTerminate = No
END IF
GOTO NewHelpPage
CASE ELSE ' Other Length 1 Key
GOTO BadHelpKey
END SELECT
CASE 2 ' Length 2 Keys
' Length 2 keys -- Next,Prev,First,Last,SpecificPage
SELECT CASE InString(CHR$(PgUp) + CHR$(PgDn) + CHR$(HomeKey) + _
CHR$(EndKey) + CHR$(Ins), RIGHT$(Keystroke$, N1))
CASE 1, 3 ' PgUp or Home
IF CurrentPage <= N1 THEN GOTO BadHelpKey
' Pg Up or Home
IF RIGHT$(Keystroke$, N1) = CHR$(PgUp) THEN
CurrentPage = CurrentPage - N1 'PgUp
ELSE
CurrentPage = N1 'Home
END IF
GOTO NewHelpPage
CASE 2, 4 ' PgDn or End
IF CurrentPage >= LastPage THEN GOTO BadHelpKey
IF RIGHT$(Keystroke$, N1) = CHR$(PgDn) THEN
CurrentPage = CurrentPage + N1 'PgDn
ELSE
CurrentPage = LastPage 'End
END IF
GOTO NewHelpPage
CASE 5 ' Ins (Specific Page)
CALL ShowErase(N6, N22, N1, N26, Blank0$)'clear instructions
CALL ShowMult(N6, N23, N1, N42, N3) ' & for Ins Prompt
InputResponse$ = MID$(STR$(CurrentPage), N2, N2)
CALL ControlledInput(N22, N2, N22, N6, N3, _
"Enter Page Number", InputResponse$, _
N1, N0, N1, N1)
CurrentPage = VAL(InputResponse$)
IF CurrentPage < N1 THEN CurrentPage = N1
IF CurrentPage > LastPage THEN CurrentPage = LastPage
GOTO NewHelpPage
CASE ELSE
BadHelpKey:
CALL MinorBeeper
GOTO NextHelpKey
END SELECT
END SELECT
HelpExit:
Subnum = SubnumSave
END SUB
'=========================================================================
SUB IncrementDate (DateToIncrement$) STATIC
'=========================================================================
' Given A Date, Find The Next One
' Increment Date
DEFINT A-Z
SubnumSave = Subnum
Subnum = 31
IncrementYear = VAL(MID$(DateToIncrement$, N1, 4))
IncrementMonth = VAL(MID$(DateToIncrement$, 5, N2))
IncrementDay = VAL(MID$(DateToIncrement$, N7, N2))
IF IncrementMonth <> N2 OR IncrementDay <> 28 THEN ' Not Leap Year
IF IncrementDay < MonthLength(IncrementMonth) THEN
IncrementDay = IncrementDay + N1
GOTO DoLeap
END IF
IncrementDay = N1
' Last Day
IF IncrementMonth = 12 THEN ' Last Month
IncrementMonth = N1
IncrementYear = IncrementYear + N1
GOTO DoLeap
END IF
IncrementMonth = IncrementMonth + N1
GOTO DoLeap
END IF
' Leap Year Test
IF Leap(IncrementYear) THEN
IncrementMonth = N2
IncrementDay = 29
ELSE
IncrementMonth = N3
IncrementDay = N1
END IF
' Leap Year
DoLeap:
CALL YearAdjust(IncrementYear, AdjustedYear$)
DateToIncrement$ = ZeroFill$(AdjustedYear$ + RIGHT$(STR$(IncrementMonth), _
N2) + RIGHT$(STR$(IncrementDay), N2))
Subnum = SubnumSave
END SUB
'=========================================================================
SUB InitPrinter STATIC
'=========================================================================
' Printer Initialization
DEFINT A-Z
SubnumSave = Subnum
Subnum = 33
WIDTH LPRINT 84
IF SelectedPrinter$ <> Hyphen$ THEN
' Init Printer
FOR I = N1 TO 50
CALL KeyStuff(KeyStatus)
IF PrinterCodes(I) = -99 THEN
EXIT FOR
ELSE
CALL LprintString((CHR$(PrinterCodes(I))), N1)
IF LprintTerminate THEN
EXIT FOR
END IF
END IF
NEXT
END IF
PrinterLineCount = 1
Subnum = SubnumSave
END SUB
'=========================================================================
'======================== END OF CAL3.BAS =============================
'========================================================================